home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / kcl-system-patches.lisp < prev    next >
Lisp/Scheme  |  1992-06-04  |  4KB  |  126 lines
  1.  
  2. (in-package 'system)
  3.  
  4.  
  5. #|| ;This isn't needed for clue anymore, so I have commented it out.
  6. ;[The reason it isn't needed is that with this fix, I found that 
  7. ;call-arguments-limit was being exceeded, ;and so I added code to 
  8. ;remove unwanted keyword arguments first.]
  9.  
  10. ;clue has a call to xlib:create-window in intrinsics.lisp that causes problems.
  11.  
  12. ;It isn't quite right to have a fixed upper argument length limit for 
  13. ;functions having keyword arguments because :allow-other-keys might be an
  14. ;argument.  The following patch fixes it.  
  15. ;(The right way to fix this is to change the appropriate calls to 
  16. ;add-init in cmptop.lsp, instead of this patch.)
  17. #+akcl
  18. (progn
  19. (clines "
  20. object siSPinit,siSPmemory;
  21. object MFvfun_key();
  22. #define PADDR(i) ((char *)(siSPinit->s.s_dbind->fixa.fixa_self[fix(i)]))
  23. #define call_MFvfun_key(sym,self,argd,keys) \\
  24.         MFvfun_key(sym,PADDR(self),fix(argd)|0xff00,siSPmemory->s.s_dbind,PADDR(keys));
  25. ")
  26.  
  27. ;The "|0xff00" above increases the vfun max args to 255 to allow for
  28. ;the :allow-other-keys argument.  When :allow-other-keys is present,
  29. ;there might be any number of arguments.
  30.  
  31. (defentry MFVFUN-KEY (object object object object) (object "call_MFvfun_key"))
  32.  
  33. ;;;;;;;;;
  34.  
  35. (clines "
  36. object fix_existing_key_vfun(vfun)
  37.    object vfun;
  38. {
  39.   if(type_of(vfun) == t_vfun) 
  40.     {vfun->vfn.vfn_maxargs = 0Xff;}
  41.   return vfun;
  42. }
  43. ")
  44.  
  45. (defentry fix-existing-key-vfun (object) (object "fix_existing_key_vfun"))
  46.  
  47. (defun fix-existing-key-vfuns (syms)
  48.   (dolist (sym syms)
  49.     (fix-existing-key-vfun (symbol-function sym))))
  50. )
  51. ||#
  52.  
  53. #+akcl
  54. (eval-when (compile load eval)
  55. (when (<= system::*akcl-version* 609)
  56.   (pushnew :pre_akcl_610 *features*))
  57. )
  58.  
  59. #+pre_akcl_610
  60. (progn
  61.  
  62. (proclaim '(optimize (safety 2) (space 3)))
  63.  
  64. ;[need this for clx/trace]
  65. ;added the call to best-array-element-type
  66. (defun make-sequence (type size &key (initial-element nil iesp)
  67.                                 &aux element-type sequence)
  68.   (setq element-type
  69.         (cond ((eq type 'list)
  70.                (return-from make-sequence
  71.                 (if iesp
  72.                     (make-list size :initial-element initial-element)
  73.                     (make-list size))))
  74.               ((or (eq type 'simple-string) (eq type 'string)) 'string-char)
  75.               ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)
  76.               ((or (eq type 'simple-vector) (eq type 'vector)) t)
  77.               (t
  78.                (setq type (normalize-type type))
  79.                (when (eq (car type) 'list)
  80.                      (return-from make-sequence
  81.                       (if iesp
  82.                           (make-list size :initial-element initial-element)
  83.                           (make-list size))))
  84.                (unless (or (eq (car type) 'array)
  85.                            (eq (car type) 'simple-array))
  86.                        (error "~S is not a sequence type." type))
  87.                (or (cadr type) t))))
  88.   (setq element-type (best-array-element-type element-type))
  89.   (setq sequence (make-vector element-type size nil nil nil nil nil))
  90.   (when iesp
  91.         (do ((i 0 (1+ i))
  92.              (size size))
  93.             ((>= i size))
  94.           (declare (fixnum i size))
  95.           (setf (elt sequence i) initial-element)))
  96.   sequence)
  97.  
  98. ;The original version (in c/predicate.c) ignores the possibility that 
  99. ;arrays and vectors can have non-T element types.
  100. (defun contains-sharp-comma (x)
  101.   (typecase x
  102.     (complex (or (contains-sharp-comma (realpart x))
  103.          (contains-sharp-comma (imagpart x))))
  104.     (vector  (and (eq 't (array-element-type x))
  105.           (some #'contains-sharp-comma x)))
  106.     (cons    (or (eq '|#,| (car x))
  107.          (contains-sharp-comma (car x))
  108.          (contains-sharp-comma (cdr x))))
  109.     (array   (and (eq 't (array-element-type x))
  110.           (let* ((rank (array-rank x))
  111.              (dimensions (make-list rank)))
  112.             (dotimes (i rank)
  113.               (setf (nth i dimensions) (array-dimension x i)))
  114.             (unless (member 0 dimensions)
  115.               (do ((cursor (make-list rank :initial-element 0)))
  116.               (nil)
  117.             (declare (:dynamic-extent cursor))
  118.             (when (contains-sharp-comma (apply #'aref x cursor))
  119.               (return t))
  120.             (when (increment-cursor cursor dimensions)
  121.               (return nil)))))))
  122.     (t (structurep x))))
  123.           
  124.  
  125. )
  126.